home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
kcl.lha
/
lsp
/
setf.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-04
|
18KB
|
474 lines
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
;;;; setf.lsp
;;;;
;;;; setf routines
(in-package 'lisp)
(export '(setf psetf shiftf rotatef
define-modify-macro defsetf
getf remf incf decf push pushnew pop
define-setf-method get-setf-method get-setf-method-multiple-value))
(in-package 'system)
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
(eval-when (eval compile) (defun si:clear-compiler-properties (symbol)))
(eval-when (eval compile) (setq si:*inhibit-macro-special* nil))
;;; DEFSETF macro.
(defmacro defsetf (access-fn &rest rest)
(cond ((and (car rest) (or (symbolp (car rest)) (functionp (car rest))))
`(progn (si:putprop ',access-fn ',(car rest) 'setf-update-fn)
(remprop ',access-fn 'setf-lambda)
(remprop ',access-fn 'setf-method)
(si:putprop ',access-fn
,(when (not (endp (cdr rest)))
(unless (stringp (cadr rest))
(error "A doc-string expected."))
(unless (endp (cddr rest))
(error "Extra arguments."))
(cadr rest))
'setf-documentation)
',access-fn))
(t
(unless (= (list-length (cadr rest)) 1)
(error "(store-variable) expected."))
`(progn (si:putprop ',access-fn ',rest 'setf-lambda)
(remprop ',access-fn 'setf-update-fn)
(remprop ',access-fn 'setf-method)
(si:putprop ',access-fn
,(find-documentation (cddr rest))
'setf-documentation)
',access-fn))))
;;; DEFINE-SETF-METHOD macro.
(defmacro define-setf-method (access-fn &rest rest)
`(progn (si:putprop ',access-fn #'(lambda ,@rest) 'setf-method)
(remprop ',access-fn 'setf-lambda)
(remprop ',access-fn 'setf-update-fn)
(si:putprop ',access-fn
,(find-documentation (cdr rest))
'setf-documentation)
',access-fn))
;;; GET-SETF-METHOD.
;;; It just calls GET-SETF-METHOD-MULTIPLE-VALUE
;;; and checks the number of the store variable.
(defun get-setf-method (form)
(multiple-value-bind (vars vals stores store-form access-form)
(get-setf-method-multiple-value form)
(unless (= (list-length stores) 1)
(error "Multiple store-variables are not allowed."))
(values vars vals stores store-form access-form)))
;;;; GET-SETF-METHOD-MULTIPLE-VALUE.
(defun get-setf-method-multiple-value (form)
(cond ((symbolp form)
(let ((store (gensym)))
(values nil nil (list store) `(setq ,form ,store) form)))
((or (not (consp form)) (not (symbolp (car form))))
(error "Cannot get the setf-method of ~S." form))
((get (car form) 'setf-method)
(apply (get (car form) 'setf-method) (cdr form)))
((get (car form) 'setf-update-fn)
(let ((vars (mapcar #'(lambda (x)
(declare (ignore x))
(gensym))
(cdr form)))
(store (gensym)))
(values vars (cdr form) (list store)
`(,(get (car form) 'setf-update-fn)
,@vars ,store)
(cons (car form) vars))))
((get (car form) 'setf-lambda)
(let* ((vars (mapcar #'(lambda (x)
(declare (ignore x))
(gensym))
(cdr form)))
(store (gensym))
(l (get (car form) 'setf-lambda))
(f `(lambda ,(car l) #'(lambda ,(cadr l) ,@(cddr l)))))
(values vars (cdr form) (list store)
(funcall (apply f vars) store)
(cons (car form) vars))))
((macro-function (car form))
(get-setf-method-multiple-value (macroexpand form)))
(t
(error "Cannot expand the SETF form ~S." form))))
;;;; SETF definitions.
(defsetf car (x) (y) `(progn (rplaca ,x ,y) ,y))
(defsetf cdr (x) (y) `(progn (rplacd ,x ,y), y))
(defsetf caar (x) (y) `(progn (rplaca (car ,x) ,y) ,y))
(defsetf cdar (x) (y) `(progn (rplacd (car ,x) ,y) ,y))
(defsetf cadr (x) (y) `(progn (rplaca (cdr ,x) ,y) ,y))
(defsetf cddr (x) (y) `(progn (rplacd (cdr ,x) ,y) ,y))
(defsetf caaar (x) (y) `(progn (rplaca (caar ,x) ,y) ,y))
(defsetf cdaar (x) (y) `(progn (rplacd (caar ,x) ,y) ,y))
(defsetf cadar (x) (y) `(progn (rplaca (cdar ,x) ,y) ,y))
(defsetf cddar (x) (y) `(progn (rplacd (cdar ,x) ,y) ,y))
(defsetf caadr (x) (y) `(progn (rplaca (cadr ,x) ,y) ,y))
(defsetf cdadr (x) (y) `(progn (rplacd (cadr ,x) ,y) ,y))
(defsetf caddr (x) (y) `(progn (rplaca (cddr ,x) ,y) ,y))
(defsetf cdddr (x) (y) `(progn (rplacd (cddr ,x) ,y) ,y))
(defsetf caaaar (x) (y) `(progn (rplaca (caaar ,x) ,y) ,y))
(defsetf cdaaar (x) (y) `(progn (rplacd (caaar ,x) ,y) ,y))
(defsetf cadaar (x) (y) `(progn (rplaca (cdaar ,x) ,y) ,y))
(defsetf cddaar (x) (y) `(progn (rplacd (cdaar ,x) ,y) ,y))
(defsetf caadar (x) (y) `(progn (rplaca (cadar ,x) ,y) ,y))
(defsetf cdadar (x) (y) `(progn (rplacd (cadar ,x) ,y) ,y))
(defsetf caddar (x) (y) `(progn (rplaca (cddar ,x) ,y) ,y))
(defsetf cdddar (x) (y) `(progn (rplacd (cddar ,x) ,y) ,y))
(defsetf caaadr (x) (y) `(progn (rplaca (caadr ,x) ,y) ,y))
(defsetf cdaadr (x) (y) `(progn (rplacd (caadr ,x) ,y) ,y))
(defsetf cadadr (x) (y) `(progn (rplaca (cdadr ,x) ,y) ,y))
(defsetf cddadr (x) (y) `(progn (rplacd (cdadr ,x) ,y) ,y))
(defsetf caaddr (x) (y) `(progn (rplaca (caddr ,x) ,y) ,y))
(defsetf cdaddr (x) (y) `(progn (rplacd (caddr ,x) ,y) ,y))
(defsetf cadddr (x) (y) `(progn (rplaca (cdddr ,x) ,y) ,y))
(defsetf cddddr (x) (y) `(progn (rplacd (cdddr ,x) ,y) ,y))
(defsetf first (x) (y) `(progn (rplaca ,x ,y) ,y))
(defsetf second (x) (y) `(progn (rplaca (cdr ,x) ,y) ,y))
(defsetf third (x) (y) `(progn (rplaca (cddr ,x) ,y) ,y))
(defsetf fourth (x) (y) `(progn (rplaca (cdddr ,x) ,y) ,y))
(defsetf fifth (x) (y) `(progn (rplaca (cddddr ,x) ,y) ,y))
(defsetf sixth (x) (y) `(progn (rplaca (nthcdr 5 ,x) ,y) ,y))
(defsetf seventh (x) (y) `(progn (rplaca (nthcdr 6 ,x) ,y) ,y))
(defsetf eighth (x) (y) `(progn (rplaca (nthcdr 7 ,x) ,y) ,y))
(defsetf ninth (x) (y) `(progn (rplaca (nthcdr 8 ,x) ,y) ,y))
(defsetf tenth (x) (y) `(progn (rplaca (nthcdr 9 ,x) ,y) ,y))
(defsetf rest (x) (y) `(progn (rplacd ,x ,y) ,y))
(defsetf svref si:svset)
(defsetf elt si:elt-set)
(defsetf symbol-value set)
(defsetf symbol-function si:fset)
(defsetf macro-function (s) (v) `(progn (si:fset ,s (cons 'macro ,v)) ,v))
(defsetf aref si:aset)
(defsetf get (s p &optional d) (v) `(si:putprop ,s ,v ,p))
(defsetf nth (n l) (v) `(progn (rplaca (nthcdr ,n ,l) ,v) ,v))
(defsetf char si:char-set)
(defsetf schar si:schar-set)
(defsetf bit si:aset)
(defsetf sbit si:aset)
(defsetf fill-pointer si:fill-pointer-set)
(defsetf symbol-plist si:set-symbol-plist)
(defsetf gethash (k h &optional d) (v) `(si:hash-set ,k ,h ,v))
(defsetf documentation (s d) (v)
`(case ,d
(variable (si:putprop ,s ,v 'variable-documentation))
(function (si:putprop ,s ,v 'function-documentation))
(structure (si:putprop ,s ,v 'structure-documentation))
(type (si:putprop ,s ,v 'type-documentation))
(setf (si:putprop ,s ,v 'setf-documentation))
(t (error "~S is an illegal documentation type." ,d))))
(define-setf-method getf (place indicator &optional default)
(multiple-value-bind (vars vals stores store-form access-form)
(get-setf-method place)
(let ((itemp (gensym)) (store (gensym)))
(values `(,@vars ,itemp)
`(,@vals ,indicator)
(list store)
`(let ((,(car stores) (si:put-f ,access-form ,store ,itemp)))
,store-form
,store)
`(getf ,access-form ,itemp ,default)))))
(defsetf subseq (sequence1 start1 &optional end1)
(sequence2)
`(replace ,sequence1 ,sequence2 :start1 ,start1 :end1 ,end1))
(define-setf-method the (type form)
(multiple-value-bind (vars vals stores store-form access-form)
(get-setf-method form)
(let ((store (gensym)))
(values vars vals (list store)
`(let ((,(car stores) (the ,type ,store))) ,store-form)
`(the ,type ,access-form)))))
#|
(define-setf-method apply (fn &rest rest)
(unless (and (consp fn) (eq (car fn) 'function) (symbolp (cadr fn))
(null (cddr fn)))
(error "Can't get the setf-method of ~S." fn))
(multiple-value-bind (vars vals stores store-form access-form)
(get-setf-method (cons (cadr fn) rest))
(unless (eq (car (last store-form)) (car (last vars)))
(error "Can't get the setf-method of ~S." fn))
(values vars vals stores
`(apply #',(car store-form) ,@(cdr store-form))
`(apply #',(cadr fn) ,@(cdr access-form)))))
|#
(define-setf-method apply (fn &rest rest)
(unless (and (consp fn)
(or (eq (car fn) 'function) (eq (car fn) 'quote))
(symbolp (cadr fn))
(null (cddr fn)))
(error "Can't get the setf-method of ~S." fn))
(multiple-value-bind (vars vals stores store-form access-form)
(get-setf-method (cons (cadr fn) rest))
(cond ((eq (car (last store-form)) (car (last vars)))
(values vars vals stores
`(apply #',(car store-form) ,@(cdr store-form))
`(apply #',(cadr fn) ,@(cdr access-form))))
((eq (car (last (butlast store-form))) (car (last vars)))
(values vars vals stores
`(apply #',(car store-form)
,@(cdr (butlast store-form 2))
(append ,(car (last (butlast store-form)))
(list ,(car (last store-form)))))
`(apply #',(cadr fn) ,@(cdr access-form))))
(t (error "Can't get the setf-method of ~S." fn)))))
(define-setf-method char-bit (char name)
(multiple-value-bind (temps vals stores store-form access-form)
(get-setf-method char)
(let ((ntemp (gensym))
(store (gensym))
(stemp (first stores)))
(values `(,ntemp ,@temps)
`(,name ,@vals)
(list store)
`(let ((,stemp (set-char-bit ,access-form ,ntemp ,store)))
,store-form ,store)
`(char-bit ,access-form ,ntemp)))))
(define-setf-method ldb (bytespec int)
(multiple-value-bind (temps vals stores store-form access-form)
(get-setf-method int)
(let ((btemp (gensym))
(store (gensym))
(stemp (first stores)))
(values `(,btemp ,@temps)
`(,bytespec ,@vals)
(list store)
`(let ((,stemp (dpb ,store ,btemp ,access-form)))
,store-form ,store)
`(ldb ,btemp ,access-form)))))
(define-setf-method mask-field (bytespec int)
(multiple-value-bind (temps vals stores store-form access-form)
(get-setf-method int)
(let ((btemp (gensym))
(store (gensym))
(stemp (first stores)))
(values `(,btemp ,@temps)
`(,bytespec ,@vals)
(list store)
`(let ((,stemp (deposit-field ,store ,btemp ,access-form)))
,store-form ,store)
`(mask-field ,btemp ,access-form)))))
;;; The expansion function for SETF.
(defun setf-expand-1 (place newvalue &aux g)
(when (and (consp place) (eq (car place) 'the))
(return-from setf-expand-1
(setf-expand-1 (caddr place) `(the ,(cadr place) ,newvalue))))
(when (symbolp place)
(return-from setf-expand-1 `(setq ,place ,newvalue)))
(when (and (symbolp (car place)) (setq g (get (car place) 'setf-update-fn)))
(return-from setf-expand-1 `(,g ,@(cdr place) ,newvalue)))
(when (and (symbolp (car place))
(setq g (get (car place) 'structure-access))
(get (car place) 'setf-lambda)
(not (eq (car g) 'list))
(not (eq (car g) 'vector)))
(return-from setf-expand-1
`(si:structure-set ,(cadr place) ',(car g) ,(cdr g) ,newvalue)))
(multiple-value-bind (vars vals stores store-form access-form)
(get-setf-method place)
(declare (ignore access-form))
`(let* ,(mapcar #'list
(append vars stores)
(append vals (list newvalue)))
,store-form)))
(defun setf-expand (l)
(cond ((endp l) nil)
((endp (cdr l)) (error "~S is an illegal SETF form." l))
(t
(cons (setf-expand-1 (car l) (cadr l))
(setf-expand (cddr l))))))
;;; SETF macro.
(defmacro setf (&rest rest)
(cond ((endp rest) nil)
((endp (cdr rest)) (error "~S is an illegal SETF form." rest))
((endp (cddr rest)) (setf-expand-1 (car rest) (cadr rest)))
(t (cons 'progn (setf-expand rest)))))
;;; PSETF macro.
(defmacro psetf (&rest rest)
(cond ((endp rest) nil)
((endp (cdr rest)) (error "~S is an illegal PSETF form." rest))
((endp (cddr rest))
`(progn ,(setf-expand-1 (car rest) (cadr rest))
nil))
(t
(do ((r rest (cddr r))
(pairs nil)
(store-forms nil))
((endp r)
`(let* ,pairs
,@(nreverse store-forms)
nil))
(when (endp (cdr r)) (error "~S is an illegal PSETF form." rest))
(multiple-value-bind (vars vals stores store-form access-form)
(get-setf-method (car r))
(declare (ignore access-form))
(setq store-forms (cons store-form store-forms))
(setq pairs
(nconc pairs
(mapcar #'list
(append vars stores)
(append vals (list (cadr r)))))))))))
;;; SHIFTF macro.
(defmacro shiftf (&rest rest)
(do ((r rest (cdr r))
(pairs nil)
(stores nil)
(store-forms nil)
(g (gensym))
(access-forms nil))
((endp (cdr r))
(setq stores (nreverse stores))
(setq store-forms (nreverse store-forms))
(setq access-forms (nreverse access-forms))
`(let* ,(nconc pairs
(list (list g (car access-forms)))
(mapcar #'list stores (cdr access-forms))
(list (list (car (last stores)) (car r))))
,@store-forms
,g))
(multiple-value-bind (vars vals stores1 store-form access-form)
(get-setf-method (car r))
(setq pairs (nconc pairs (mapcar #'list vars vals)))
(setq stores (cons (car stores1) stores))
(setq store-forms (cons store-form store-forms))
(setq access-forms (cons access-form access-forms)))))
;;; ROTATEF macro.
(defmacro rotatef (&rest rest)
(do ((r rest (cdr r))
(pairs nil)
(stores nil)
(store-forms nil)
(access-forms nil))
((endp r)
(setq stores (nreverse stores))
(setq store-forms (nreverse store-forms))
(setq access-forms (nreverse access-forms))
`(let* ,(nconc pairs
(mapcar #'list stores (cdr access-forms))
(list (list (car (last stores)) (car access-forms))))
,@store-forms))
(multiple-value-bind (vars vals stores1 store-form access-form)
(get-setf-method (car r))
(setq pairs (nconc pairs (mapcar #'list vars vals)))
(setq stores (cons (car stores1) stores))
(setq store-forms (cons store-form store-forms))
(setq access-forms (cons access-form access-forms)))))
;;; DEFINE-MODIFY-MACRO macro.
(defmacro define-modify-macro (name lambda-list function &optional doc-string)
(let ((update-form
(do ((l lambda-list (cdr l))
(vs nil))
((null l) `(list ',function access-form ,@(nreverse vs)))
(unless (eq (car l) '&optional)
(if (eq (car l) '&rest)
(return `(list* ',function
access-form
,@(nreverse vs)
,(cadr l))))
(if (symbolp (car l))
(setq vs (cons (car l) vs))
(setq vs (cons (caar l) vs)))))))
`(defmacro ,name (reference . ,lambda-list)
,@(if doc-string (list doc-string))
(when (symbolp reference)
(return-from ,name
(let ((access-form reference))
(list 'setq reference ,update-form))))
(multiple-value-bind (vars vals stores store-form access-form)
(get-setf-method reference)
(list 'let*
(mapcar #'list
(append vars stores)
(append vals (list ,update-form)))
store-form))))))))))))))))))))
;;; Some macro definitions.
(defmacro remf (place indicator)
(multiple-value-bind (vars vals stores store-form access-form)
(get-setf-method place)
`(let* ,(mapcar #'list vars vals)
(multiple-value-bind (,(car stores) flag)
(si:rem-f ,access-form ,indicator)
,store-form
flag))))
(define-modify-macro incf (&optional (delta 1)) +)
(define-modify-macro decf (&optional (delta 1)) -)
(defmacro push (item place)
(when (symbolp place)
(return-from push `(setq ,place (cons ,item ,place))))
(multiple-value-bind (vars vals stores store-form access-form)
(get-setf-method place)
`(let* ,(mapcar #'list
(append vars stores)
(append vals (list (list 'cons item access-form))))
,store-form)))
(defmacro pushnew (item place &rest rest)
(multiple-value-bind (vars vals stores store-form access-form)
(get-setf-method place)
`(let* ,(mapcar #'list
(append vars stores)
(append vals
(list (list* 'adjoin item access-form rest))))
,store-form)))
(defmacro pop (place)
(when (symbolp place)
(return-from pop
(let ((temp (gensym)))
`(let ((,temp (car ,place)))
(setq ,place (cdr ,place))
,temp))))
(multiple-value-bind (vars vals stores store-form access-form)
(get-setf-method place)
`(let* ,(mapcar #'list
(append vars stores)
(append vals (list (list 'cdr access-form))))
(prog1 (car ,access-form)
,store-form))))